Visual Basic Source Code

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / sendun1a / frmdata.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1999-10-22 | 40.5 KB | 1,142 lines

VERSION 5.00 Object = "{BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0"; "TABCTL32.OCX" Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.2#0"; "COMCTL32.OCX" Begin VB.Form frmData BackColor = &H00C0C0C0& Caption = "Dev Mailer" ClientHeight = 5895 ClientLeft = 60 ClientTop = 345 ClientWidth = 10275 FillColor = &H00C0C0C0& ForeColor = &H00C0C0C0& Icon = "frmData.frx":0000 LinkTopic = "Form1" MaxButton = 0 'False MouseIcon = "frmData.frx":27A2 ScaleHeight = 5895 ScaleWidth = 10275 StartUpPosition = 2 'CenterScreen Begin VB.PictureBox picLogo AutoRedraw = -1 'True BackColor = &H00000000& BorderStyle = 0 'None BeginProperty Font Name = "Arial" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H80000005& Height = 9375 Left = 0 ScaleHeight = 9375 ScaleWidth = 255 TabIndex = 30 TabStop = 0 'False Top = 0 Width = 255 End Begin TabDlg.SSTab ssData Height = 5850 Left = 255 TabIndex = 31 Top = 30 Width = 9960 _ExtentX = 17568 _ExtentY = 10319 _Version = 327681 Style = 1 Tabs = 2 TabsPerRow = 2 TabHeight = 520 BackColor = 12632256 TabCaption(0) = "&Redacci TabPicture(0) = "frmData.frx":2AAC Tab(0).ControlEnabled= -1 'True Tab(0).Control(0)= "Label5" Tab(0).Control(0).Enabled= 0 'False Tab(0).Control(1)= "Label2" Tab(0).Control(1).Enabled= 0 'False Tab(0).Control(2)= "Label4" Tab(0).Control(2).Enabled= 0 'False Tab(0).Control(3)= "Label1" Tab(0).Control(3).Enabled= 0 'False Tab(0).Control(4)= "Process" Tab(0).Control(4).Enabled= 0 'False Tab(0).Control(5)= "pix" Tab(0).Control(5).Enabled= 0 'False Tab(0).Control(6)= "cmdAddAttach" Tab(0).Control(6).Enabled= 0 'False Tab(0).Control(7)= "cmdDelAttach" Tab(0).Control(7).Enabled= 0 'False Tab(0).Control(8)= "DataArrival" Tab(0).Control(8).Enabled= 0 'False Tab(0).Control(9)= "Command4" Tab(0).Control(9).Enabled= 0 'False Tab(0).Control(10)= "Command3" Tab(0).Control(10).Enabled= 0 'False Tab(0).Control(11)= "tmr" Tab(0).Control(11).Enabled= 0 'False Tab(0).Control(12)= "Frame1" Tab(0).Control(12).Enabled= 0 'False Tab(0).Control(13)= "btnFecha" Tab(0).Control(13).Enabled= 0 'False Tab(0).Control(14)= "Text4" Tab(0).Control(14).Enabled= 0 'False Tab(0).Control(15)= "Text2" Tab(0).Control(15).Enabled= 0 'False Tab(0).Control(16)= "Command2" Tab(0).Control(16).Enabled= 0 'False Tab(0).Control(17)= "Command1" Tab(0).Control(17).Enabled= 0 'False Tab(0).Control(18)= "Text1" Tab(0).Control(18).Enabled= 0 'False Tab(0).Control(19)= "lstAttachment" Tab(0).Control(19).Enabled= 0 'False Tab(0).ControlCount= 20 TabCaption(1) = "&Configuraci TabPicture(1) = "frmData.frx":2AC8 Tab(1).ControlEnabled= 0 'False Tab(1).Control(0)= "cmdApply" Tab(1).Control(0).Enabled= 0 'False Tab(1).Control(1)= "Frame2" Tab(1).Control(1).Enabled= 0 'False Tab(1).Control(2)= "Frame3" Tab(1).Control(2).Enabled= 0 'False Tab(1).Control(3)= "cmdDelReg" Tab(1).Control(3).Enabled= 0 'False Tab(1).Control(4)= "Command5" Tab(1).Control(4).Enabled= 0 'False Tab(1).ControlCount= 5 Begin VB.CommandButton Command5 BackColor = &H00808080& Caption = "&Salir" Height = 375 Left = -73140 TabIndex = 29 Top = 5310 Width = 1215 End Begin VB.CommandButton cmdDelReg Appearance = 0 'Flat Height = 345 Left = -73590 Picture = "frmData.frx":2AE4 Style = 1 'Graphical TabIndex = 28 ToolTipText = "Cancelar Operaci Top = 5340 Width = 345 End Begin VB.Frame Frame3 Caption = "Informaci n del usuario" Height = 795 Left = -74910 TabIndex = 26 Top = 1650 Width = 5205 Begin VB.TextBox txtMailSend Height = 315 IMEMode = 3 'DISABLE Left = 2040 TabIndex = 32 Top = 300 Width = 2625 End Begin VB.Label Label10 AutoSize = -1 'True Caption = "&Direcci n de Correo:" Height = 195 Left = 210 TabIndex = 33 Top = 360 Width = 1455 End End Begin VB.Frame Frame2 Caption = "Informaci n del Servidor" Height = 1125 Left = -74910 TabIndex = 21 Top = 450 Width = 5205 Begin VB.TextBox txtSMTP Height = 315 IMEMode = 3 'DISABLE Left = 1980 MaxLength = 20 TabIndex = 23 Top = 270 Width = 3015 End Begin VB.TextBox txtSMTPport Height = 315 IMEMode = 3 'DISABLE Left = 1980 MaxLength = 20 TabIndex = 25 Text = "25" Top = 660 Width = 1125 End Begin VB.Label Label7 AutoSize = -1 'True Caption = "&Puerto de Salida:" Height = 195 Left = 150 TabIndex = 24 Top = 720 Width = 1215 End Begin VB.Label Label3 AutoSize = -1 'True Caption = "Correo saliente (SMTP):" Height = 195 Left = 120 TabIndex = 22 Top = 330 Width = 1680 End End Begin VB.CommandButton cmdApply BackColor = &H00808080& Caption = "&Aplicar" Height = 375 Left = -74880 TabIndex = 27 Top = 5310 Width = 1215 End Begin ComctlLib.ListView lstAttachment Height = 2235 Left = 4710 TabIndex = 12 Top = 1470 Width = 5175 _ExtentX = 9128 _ExtentY = 3942 View = 3 LabelEdit = 1 Sorted = -1 'True MultiSelect = -1 'True LabelWrap = -1 'True HideSelection = -1 'True _Version = 327682 ForeColor = -2147483640 BackColor = -2147483643 BorderStyle = 1 Appearance = 1 NumItems = 2 BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7} Key = "" Object.Tag = "" Text = "Archivo" Object.Width = 4410 EndProperty BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7} SubItemIndex = 1 Key = "" Object.Tag = "" Text = "Ubicaci Object.Width = 4410 EndProperty End Begin VB.TextBox Text1 Height = 315 Left = 4710 MaxLength = 100 TabIndex = 6 Top = 1050 Width = 1185 End Begin VB.CommandButton Command1 BackColor = &H00808080& Caption = "&Enviar " Height = 375 Left = 4710 TabIndex = 17 Top = 5370 Width = 1215 End Begin VB.CommandButton Command2 BackColor = &H00808080& Caption = "&Salir" Height = 375 Left = 8670 TabIndex = 20 Top = 5370 Width = 1215 End Begin VB.TextBox Text2 Height = 315 Left = 6090 MaxLength = 100 TabIndex = 8 Top = 1050 Width = 1185 End Begin VB.TextBox Text4 Height = 315 Left = 7470 Locked = -1 'True TabIndex = 10 Top = 1050 Width = 1275 End Begin VB.CommandButton btnFecha Appearance = 0 'Flat Height = 315 Left = 8790 Picture = "frmData.frx":2C2E Style = 1 'Graphical TabIndex = 11 ToolTipText = "Seleccionar Fecha" Top = 1050 Width = 345 End Begin VB.Frame Frame1 BackColor = &H00C0C0C0& Caption = "Informaci ForeColor = &H00000000& Height = 4965 Left = 60 TabIndex = 0 Top = 360 Width = 4455 Begin VB.PictureBox Picture1 Appearance = 0 'Flat AutoRedraw = -1 'True AutoSize = -1 'True BackColor = &H80000005& BorderStyle = 0 'None FillStyle = 0 'Solid ForeColor = &H80000008& Height = 1110 Index = 0 Left = 1590 Picture = "frmData.frx":2DB8 ScaleHeight = 1110 ScaleWidth = 1140 TabIndex = 3 ToolTipText = "Grifo ( Belfegor)" Top = 1200 Width = 1140 End Begin VB.Label lblMailto Alignment = 2 'Center AutoSize = -1 'True BackColor = &H00000000& BackStyle = 0 'Transparent Caption = "support@yourmail.com" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = -1 'True Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00000000& Height = 195 Left = 1365 TabIndex = 2 Top = 870 Width = 1635 End Begin VB.Label Label6 Alignment = 2 'Center AutoSize = -1 'True BackColor = &H00C0C0C0& Caption = $"frmData.frx":3606 ForeColor = &H00000000& Height = 585 Left = 240 TabIndex = 1 Top = 210 Width = 4065 WordWrap = -1 'True End End Begin VB.Timer tmr Interval = 100 Left = 6900 Top = 5400 End Begin VB.CommandButton Command3 Appearance = 0 'Flat Height = 345 Left = 5970 Picture = "frmData.frx":36A0 Style = 1 'Graphical TabIndex = 18 ToolTipText = "Copiar clave al portapapeles" Top = 5400 Width = 345 End Begin VB.CommandButton Command4 Appearance = 0 'Flat Height = 345 Left = 6360 Picture = "frmData.frx":37EA Style = 1 'Graphical TabIndex = 19 ToolTipText = "Cancelar Operaci Top = 5400 Width = 345 End Begin VB.TextBox DataArrival BackColor = &H00C0C0C0& ForeColor = &H00000000& Height = 765 Left = 4710 Locked = -1 'True MaxLength = 1000 MultiLine = -1 'True ScrollBars = 2 'Vertical TabIndex = 15 TabStop = 0 'False Top = 4260 Width = 5175 End Begin VB.CommandButton cmdDelAttach BackColor = &H00808080& Caption = "&Eliminar Archivo" Height = 375 Left = 8280 TabIndex = 14 Top = 3810 Width = 1575 End Begin VB.CommandButton cmdAddAttach BackColor = &H00808080& Caption = "&Ingresar Archivo" Height = 375 Left = 4710 TabIndex = 13 Top = 3810 Width = 1485 End Begin VB.PictureBox pix AutoRedraw = -1 'True BackColor = &H00FFFFFF& Height = 315 Left = 4710 ScaleHeight = 255 ScaleWidth = 5115 TabIndex = 34 TabStop = 0 'False Top = 5010 Visible = 0 'False Width = 5175 End Begin VB.Label Process BackColor = &H00C0C0C0& BorderStyle = 1 'Fixed Single Height = 255 Left = 4710 TabIndex = 16 Top = 5070 Width = 5175 End Begin VB.Label Label1 AutoSize = -1 'True BackColor = &H00C0C0C0& Caption = "Ingrese su Informaci ForeColor = &H00000000& Height = 195 Left = 4710 TabIndex = 4 Top = 450 Width = 1650 End Begin VB.Label Label4 AutoSize = -1 'True BackColor = &H00C0C0C0& Caption = "Cliente:" ForeColor = &H00000000& Height = 195 Left = 4710 TabIndex = 5 Top = 780 Width = 525 End Begin VB.Label Label2 AutoSize = -1 'True BackColor = &H00C0C0C0& Caption = "OC:" ForeColor = &H00000000& Height = 195 Left = 6090 TabIndex = 7 Top = 780 Width = 270 End Begin VB.Label Label5 AutoSize = -1 'True BackColor = &H00C0C0C0& Caption = "Fecha Necesidad:" ForeColor = &H00000000& Height = 195 Left = 7470 TabIndex = 9 Top = 780 Width = 1305 End End Attribute VB_Name = "frmData" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit 'para env o de e-mail Dim CRLF As String Dim CRLF_CRLF As String Dim outBuffer As String Dim stKEYDATA As String Dim MAIL_DATA As MIME_DATA Dim IsConfig As Boolean Dim bTrans As Boolean Dim m_iStage As Integer Dim Sock As Integer Dim RC As Integer Dim Bytes As Integer Dim ResponseCode As Integer 'cursor animado Private hAniCursor As Long Private hBaseCursor As Long Private hResult As Long 'set de animaci Dim iPic As Byte Dim curSelect As StdPicture 'logo Dim cL As New cLogo Private Sub btnFecha_Click() SysCal.Show vbModal Set SysCal = Nothing Text4.Text = stFecha End Sub Public Function LongDateA(ByVal stdata2 As String) As String LongDateA = Right$(stdata2, 4) & Mid$(stdata2, 4, 2) & left$(stdata2, 2) End Function Private Sub cmdAddAttach_Click() Dim sOpen As SelectedFile Dim Count As Integer Dim FileList As String Dim i As Integer Dim InList As Boolean On Error GoTo e_Trap FileDialog.sFilter = "Excel (*.xls)" & Chr$(0) & "*.xls" & Chr$(0) & "All Files (*.*)" & Chr$(0) & "*.*" FileDialog.flags = OFN_EXPLORER _ Or OFN_LONGNAMES _ Or OFN_CREATEPROMPT _ Or OFN_NODEREFERENCELINKS Or _ OFN_HIDEREADONLY Or _ OFN_ALLOWMULTISELECT FileDialog.sDlgTitle = "Ingresar Attachment(s)" FileDialog.sInitDir = App.Path sOpen = ShowOpen(Me.hWnd) If Err.number <> 32755 And sOpen.bCanceled = False Then Dim itmX As ListItem For Count = 1 To sOpen.nFilesSelected If lstAttachment.ListItems.Count = 0 Then Set itmX = lstAttachment.ListItems.Add(, , sOpen.sFiles(Count)) itmX.Key = sOpen.sFiles(Count) itmX.SubItems(1) = sOpen.sLastDirectory Set itmX = Nothing Else InList = False For i = 1 To lstAttachment.ListItems.Count If sOpen.sFiles(Count) = lstAttachment.ListItems.Item(i).Key Then InList = True End If Next i If Not InList = True Then Set itmX = lstAttachment.ListItems.Add(, , sOpen.sFiles(Count)) itmX.Key = sOpen.sFiles(Count) itmX.SubItems(1) = sOpen.sLastDirectory Set itmX = Nothing End If End If Next Count FileDialog.sFile = "" End If Exit Sub e_Trap: Exit Sub Resume End Sub Private Sub cmdApply_Click() If Len(Trim$(txtSMTP.Text)) = 0 Then MsgBox "Ingrese el nombre del servidor de correo saliente", vbExclamation, Me.Caption Exit Sub End If If Len(Trim$(txtSMTPport.Text)) = 0 Then MsgBox "Ingrese el nombre puerto", vbExclamation, Me.Caption Exit Sub Else If Not IsNumeric(txtSMTPport.Text) Then MsgBox "El puerto debe ser num rico", vbExclamation, Me.Caption Exit Sub Else If Val(txtSMTPport.Text) > 65535 Or Val(txtSMTPport.Text) < 0 Then MsgBox "El valor del puerto debe estra comprendido entre 1 y 65535 (default: 25)", vbExclamation, Me.Caption Exit Sub End If End If End If If Len(Trim$(txtMailSend.Text)) = 0 Then MsgBox "Ingrese su direcci n de correo saliente", vbExclamation, Me.Caption Exit Sub End If SaveData ChargeData End Sub Private Sub cmdDelAttach_Click() Dim i As Integer For i = lstAttachment.ListItems.Count To 1 Step -1 If lstAttachment.ListItems.Item(i).Selected Then lstAttachment.ListItems.Remove (i) End If Next i End Sub Private Sub SaveData() SaveSetting App.EXEName, "mail", "status", "1" SaveSetting App.EXEName, "mail", "server", txtSMTP.Text SaveSetting App.EXEName, "mail", "port", txtSMTPport.Text SaveSetting App.EXEName, "mail", "mail", txtMailSend.Text End Sub Private Sub ChargeData() MAIL_DATA.SMTP_PORT = CLng(GetSetting(App.EXEName, "mail", "port", "25")) txtSMTPport.Text = MAIL_DATA.SMTP_PORT MAIL_DATA.SMTP_SERVER = GetSetting(App.EXEName, "mail", "server", "") txtSMTP.Text = MAIL_DATA.SMTP_SERVER MAIL_DATA.SMTP_MAILTO = GetSetting(App.EXEName, "config", "mailto", "") MAIL_DATA.SMTP_MAIL = GetSetting(App.EXEName, "mail", "mail", "") txtMailSend.Text = MAIL_DATA.SMTP_MAIL IsConfig = True End Sub Private Sub cmdDelReg_Click() DelData txtSMTP.Text = "" txtSMTPport.Text = "25" txtMailSend.Text = "" End Sub Private Sub Command1_Click() Key = GetSetting(App.EXEName, "config", "des-56", "labchile") If Len(Trim$(Text1.Text)) = 0 Then MsgBox "Debe ingresar el c digo de cliente", vbExclamation, Me.Caption Exit Sub End If If Len(Trim$(Text2.Text)) = 0 Then MsgBox "Debe ingresar la orden de compra", vbExclamation, Me.Caption Exit Sub End If stKEYDATA = "OC: " & Text1.Text & " " & Text2.Text & " " & LongDateA(Text4.Text) & " LABORATORIO CHILE S.A." stKEYDATA = Encrypt(stKEYDATA) stKEYDATA = B64(DES(stKEYDATA)) Call Initialize_WS_SOCK End Sub Private Sub Initialize_WS_SOCK() Screen.MousePointer = vbHourglass Dim StartupData As WSADataType Dim SocketBuffer As sockaddr Dim IpAddr As Long 'Inicializa Winsock RC = WSAStartup(&H101, StartupData) RC = WSAStartup(&H101, StartupData) 'Abrir un socket libre 'Se pueden abrir varias conexiones simult Sock = socket(AF_INET, SOCK_STREAM, 0) If Sock = SOCKET_ERROR Then Process.Caption = "No se puede crear el socket, reint ntelo m s tarde." Screen.MousePointer = vbDefault Exit Sub End If 'Ver si existe en HOST If RC = SOCKET_ERROR Then Exit Sub IpAddr = GetHostByNameAlias(MAIL_DATA.SMTP_SERVER) If IpAddr = -1 Then Process.Caption = "Host desconocido: " & MAIL_DATA.SMTP_SERVER Screen.MousePointer = vbDefault Exit Sub End If 'esto es responsable de la conexi SocketBuffer.sin_family = AF_INET SocketBuffer.sin_port = htons(MAIL_DATA.SMTP_PORT) SocketBuffer.sin_addr = IpAddr SocketBuffer.sin_zero = String$(8, 0) RC = connect(Sock, SocketBuffer, Len(SocketBuffer)) 'Si un error ocurre, se cierra la conexi 'mandar mensaje a la ventana If RC = SOCKET_ERROR Then Process.Caption = "No se puede conectar a: " & MAIL_DATA.SMTP_SERVER & CRLF & _ GetWSAErrorString(WSAGetLastError()) closesocket Sock RC = WSACleanup() Screen.MousePointer = vbDefault Exit Sub Else Process.Caption = "Conectado a: " & MAIL_DATA.SMTP_SERVER End If bTrans = True m_iStage = 0 DataArrival = "" ResponseCode = 220 Arrival Screen.MousePointer = vbDefault End Sub Private Sub Arrival() Dim Start As Long Dim tmr As Long Dim MsgBuffer As String * 2048 If bTrans = True Then On Error Resume Next Start = timeGetTime Do Bytes = recv(Sock, ByVal MsgBuffer, 2048, 0) DoEvents tmr = timeGetTime - Start Loop Until Bytes > 0 Or tmr > 50000 If Bytes > 0 Then DataArrival = DataArrival + _ MsgBuffer + _ Chr$(13) + Chr$(10) DataArrival.SelStart = Len(DataArrival) If ResponseCode = left(MsgBuffer, 3) Then MsgBuffer = vbNullString m_iStage = m_iStage + 1 Transmit m_iStage Bytes = 0 Arrival Else closesocket (Sock) RC = WSACleanup() Sock = 0 Process.Caption = "El servidor respondi con un c digo no esperado!" bTrans = False Exit Sub End If ElseIf WSAGetLastError() <> WSAEWOULDBLOCK Then closesocket (Sock) RC = WSACleanup() Sock = 0 bTrans = False Exit Sub Else Process.Caption = "error de servicio SMTP, tiempo fuera..." closesocket Sock RC = WSACleanup() Screen.MousePointer = vbDefault Exit Sub End If End If End Sub 'para mandar MIME Private Sub SendMimeAttachement() Dim l As Long, i As Long, FileIn As Long Dim temp As Variant Dim Files As Integer 'BASE64 *m s adelante incorporar una clase Dim b As Integer Dim Base64Tab As Variant Dim bin(3) As Byte Dim s As Variant 'Base64Tab=>tabla de tabulaci Base64Tab = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "+", "/") Process.Visible = False 'vemos cuantos archivos hay para mandar For Files = 1 To lstAttachment.ListItems.Count Erase bin l = 0: i = 0: FileIn = 0: b = 0: temp = "": s = "" FileIn = FreeFile 'BASE64 necesita binary Open lstAttachment.ListItems(Files).SubItems(1) & lstAttachment.ListItems(Files).Text For Binary Access Read As FileIn 'cabecera del mime temp = CRLF & CRLF & "----_=_--NextMimePart" + CRLF temp = temp + "Content-Type: application/octet-stream;" & CRLF temp = temp & vbTab & "name=" + Chr(34) & lstAttachment.ListItems(Files).Text & Chr(34) + CRLF temp = temp + "Content-Transfer-Encoding: base64" & CRLF temp = temp + "Content-Disposition: attachment;" & CRLF temp = temp & vbTab & "filename=" & Chr(34) & lstAttachment.ListItems(Files).Text & Chr(34) & CRLF WinsockSendData (temp & CRLF) l = LOF(FileIn) - (LOF(FileIn) Mod 3) FloodDisplay l, "enviando attachment(s)..." For i = 1 To l Step 3 'leer 3 bytes Get FileIn, , bin(0) Get FileIn, , bin(1) Get FileIn, , bin(2) 'esperar ha que hayan m s de 64 caracteres If Len(s) > 64 Then FloodUpdateText i 'Process.Caption = "Enviando Attachement..." & i & " bytes de " & l DoEvents s = s & CRLF WinsockSendData (s) s = "" End If 'Calcular caracter codificado Base64 b = (bin(0) \ 4) And &H3F '>> * 2 (&H3F=111111b) 's tiene los caracteres codificados s = s + Base64Tab(b) b = ((bin(0) And &H3) * 16) Or ((bin(1) \ 16) And &HF) s = s + Base64Tab(b) b = ((bin(1) And &HF) * 4) Or ((bin(2) \ 64) And &H3) s = s + Base64Tab(b) b = bin(2) And &H3F s = s + Base64Tab(b) Next i 'ver si hay algo dejado If Not (LOF(FileIn) Mod 3 = 0) Then 'leer bytes dejados For i = 1 To (LOF(FileIn) Mod 3) Get FileIn, , bin(i - 1) Next i 'si solo quedan 2 $ dejados If (LOF(FileIn) Mod 3) = 2 Then b = (bin(0) \ 4) And &H3F '>> * 2 (&H3F=111111b) s = s + Base64Tab(b) b = ((bin(0) And &H3) * 16) Or ((bin(1) \ 16) And &HF) s = s + Base64Tab(b) b = ((bin(1) And &HF) * 4) Or ((bin(2) \ 64) And &H3) s = s + Base64Tab(b) s = s + "=" 'so s lo hay uno Else b = (bin(0) \ 4) And &H3F '>> * 2 (&H3F=111111b) s = s + Base64Tab(b) b = ((bin(1) And &H3) * 16) Or ((bin(1) \ 16) And &HF) s = s + Base64Tab(b) s = s + "==" End If End If 'mandar caracteres dejados If s <> "" Then s = s & CRLF WinsockSendData (s) End If Close FileIn FloodHide Next Files 'manda el fin del MIME WinsockSendData (vbCrLf & "----_=_--NextMimePart--" & CRLF) WinsockSendData (CRLF_CRLF) Process.Visible = True End Sub Sub SendMimetxt() Dim temp As Variant Dim GMTTIME As String Dim i As Integer If lstAttachment.ListItems.Count > 0 Then temp = temp & "From: " & MAIL_DATA.SMTP_MAIL & CRLF temp = temp & "To: " & MAIL_DATA.SMTP_MAILTO & CRLF temp = temp & "Subject: " & stKEYDATA & CRLF temp = temp & "Date: " & Format$(Now, "ddd, dd mmm yyyy hh:nn:ss ") & Format$(CLng(GetLocalTZ(GMTTIME) / 60), "0000") & CRLF temp = temp & "Importace: high" & CRLF temp = temp & "X-Priority: 1" & CRLF temp = temp & "Sensitivity: Company -Confidential" & CRLF 'temp = temp & "MIME-Version: 1.0" & crlf 'temp = temp & vbCrLf & "Content-Type: multipart/mixed; boundary=" + _ 'Chr(34) + "NextMimePart" + Chr(34) + crlf 'temp = temp & "This is a multi-part message in MIME format." + crlf 'temp = temp & "--NextMimePart" + crlf '****MIME**** temp = temp & "MIME-Version: 1.0" & CRLF temp = temp & "Content-Type: multipart/mixed;" & CRLF temp = temp & vbTab & "boundary=" & Chr(34) & "--_=_--NextMimePart" & Chr(34) & CRLF & CRLF temp = temp & "This message is in MIME format. Since your mail reader does not understand" & CRLF temp = temp & "this format, some or all of this message may not be legible." & CRLF & CRLF '****ATTACH HEADER**** temp = temp & "----_=_--NextMimePart" & CRLF temp = temp & "Content-type= text/plain" & CRLF & CRLF 'temp = temp & "Content-Transfer-Encoding: 7bit" & crlf 'Cabecera y mensaje temp = temp & "PEDIDO PARA LABORATORIO SENDER" & CRLF & CRLF 'Mandar cabecera y mensaje WinsockSendData (temp & CRLF) 'mandar attachments Call SendMimeAttachement Else 'mail sin attachment temp = temp & "From: " & MAIL_DATA.SMTP_MAIL & CRLF temp = temp & "To: " & MAIL_DATA.SMTP_MAILTO & CRLF temp = temp & "Subject: " & stKEYDATA & CRLF temp = temp & "Date: " & Format$(Now, "ddd, dd mmm yyyy hh:nn:ss ") & Format$(CLng(GetLocalTZ(GMTTIME) / 60), "0000") & CRLF temp = temp & "Importace: high" & CRLF temp = temp & "X-Priority: 1" & CRLF temp = temp & "Sensitivity: Company -Confidential" & CRLF temp = temp & "PEDIDO PARA SENDER" & CRLF WinsockSendData (temp) WinsockSendData (CRLF_CRLF) End If End Sub Private Sub Transmit(iStage As Integer) Dim Helo As String Dim pos As Integer Select Case m_iStage Case 1: Helo = MAIL_DATA.SMTP_MAIL pos = Len(Helo) - InStr(Helo, "@") Helo = Right$(Helo, pos) ResponseCode = 250 WinsockSendData ("EHLO " & Helo & CRLF) Case 2: ResponseCode = 250 WinsockSendData ("MAIL FROM: <" & Trim$(MAIL_DATA.SMTP_MAIL) & ">" & vbCrLf) Case 3: ResponseCode = 250 WinsockSendData ("RCPT TO: <" & Trim$(MAIL_DATA.SMTP_MAILTO) & ">" & vbCrLf) Case 4: ResponseCode = 354 WinsockSendData ("DATA" & CRLF) Case 5: 'mandar header ResponseCode = 250 Call SendMimetxt 'Se termina el proceso Case 6: ResponseCode = 221 WinsockSendData ("QUIT" & CRLF) Process.Caption = "E-Mail enviado" m_iStage = 0 bTrans = False End Select End Sub Private Sub Command1_KeyPress(KeyAscii As Integer) If KeyAscii = vbKeyReturn Then Command3.SetFocus End If End Sub Private Sub Command2_Click() On Error Resume Next Call Startrek(Me) closesocket Sock RC = WSACleanup() Unload Me Set frmData = Nothing End Sub Sub Startrek(frm As Form) Dim GotoVal As Single Dim Gointo As Single GotoVal = frm.Height / 2 For Gointo = 1 To GotoVal DoEvents frm.Height = frm.Height - 100 frm.top = (Screen.Height - frm.Height) \ 2 If frm.Height <= 500 Then Exit For Next Gointo horiz: frm.Height = 30 GotoVal = frm.Width / 2 For Gointo = 1 To GotoVal DoEvents frm.Width = frm.Width - 100 frm.left = (Screen.Width - frm.Width) \ 2 If frm.Width <= 2000 Then Exit For Next Gointo End Sub Private Sub Command3_KeyPress(KeyAscii As Integer) If KeyAscii = vbKeyReturn Then Command4.SetFocus End If End Sub Private Sub Command4_Click() Clipboard.Clear Text1.Text = "" Text4.Text = Format$(Now, "dd-mm-yyyy") Text2.Text = "" End Sub Private Sub Command4_KeyPress(KeyAscii As Integer) If KeyAscii = vbKeyReturn Then Command2.SetFocus End If End Sub Private Sub Command5_Click() On Error Resume Next Call Startrek(Me) closesocket Sock RC = WSACleanup() Unload Me Set frmData = Nothing End Sub Private Sub Form_Load() DisableX Me If App.PrevInstance Then MsgBox "Este programa ya est en ejecuci n", vbCritical, Me.Caption End End If CRLF = vbCrLf CRLF_CRLF = CRLF & "." & CRLF iPic = 101 cL.DrawingObject = picLogo cL.Caption = "OE-Mailer: Name Enterprise/ Eduardo Goicovich" Text4.Text = Format$(Now, "dd-mm-yyyy") If GetSetting(App.EXEName, "config", "status", "0") = "0" Then SaveSetting App.EXEName, "config", "support", "support@yourmail.com" SaveSetting App.EXEName, "config", "mailto", "your destiny@server.com" SaveSetting App.EXEName, "config", "des-56", "key" SaveSetting App.EXEName, "config", "status", "1" End If lblMailto.Caption = GetSetting(App.EXEName, "config", "support", "support@yourmail.com") If GetSetting(App.EXEName, "mail", "status", "0") = "0" Then IsConfig = False MsgBox "Debe configurar el programa", vbExclamation, Me.Caption ssData.Tab = 1 Else ChargeData ssData.Tab = 0 End If End Sub Private Sub DelData() DeleteSetting App.EXEName, "mail" IsConfig = False End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) If hAniCursor <> 0 Then hResult = DestroyCursor(hAniCursor) hResult = SetClassLong((Frame1.hWnd), GCL_HCURSOR, hBaseCursor) hAniCursor = 0 End If End Sub Private Sub Form_Resize() On Error Resume Next picLogo.Height = Me.ScaleHeight On Error GoTo 0 cL.Draw End Sub Private Sub Frame1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) If Dir$(App.Path + "\world.ani") <> "" Then hAniCursor = LoadCursorFromFile(App.Path + "\world.ani") hResult = SetClassLong((Frame1.hWnd), GCL_HCURSOR, hAniCursor) End If End Sub Private Sub Label3_Click() Dim hiResult As Long hiResult = ShellExecute(Me.hWnd, "Open", "mailto:webmaster@labchile.cl?subject=OE-Mailer", vbNullString, App.Path, 1) End Sub Private Sub lblMailto_Click() Dim Result As Long Screen.MousePointer = vbHourglass Result = ShellExecute(Me.hWnd, "Open", "mailto:" & lblMailto.Caption & "?subject=?" & App.EXEName & " " & App.Major & "." & App.Minor & "." & App.Revision, vbNullString, App.Path, 1) Screen.MousePointer = vbNormal End Sub 'Espera hata un TIME OUT Private Sub WaitForResponse() Dim Start As Long Dim tmr As Long 'API reloj Start = timeGetTime While Bytes > 0 tmr = timeGetTime - Start DoEvents 'se esperan 50 milisec (50'') If tmr > 50000 Then Process.Caption = "error de servicio SMTP, tiempo fuera..." closesocket Sock RC = WSACleanup() Screen.MousePointer = vbDefault Exit Sub End If Wend End Sub Private Sub ssData_Click(PreviousTab As Integer) If PreviousTab = 1 Then If Not IsConfig Then ssData.Tab = 1 Else If hAniCursor <> 0 Then hResult = DestroyCursor(hAniCursor) hResult = SetClassLong((Frame1.hWnd), GCL_HCURSOR, hBaseCursor) hAniCursor = 0 End If End If End Sub Private Sub Text1_KeyPress(KeyAscii As Integer) If KeyAscii = vbKeyReturn Then Text2.SetFocus End If End Sub Private Sub WinsockSendData(DatatoSend As String) Dim RC As Integer Dim MsgBuffer As String * 2048 MsgBuffer = DatatoSend 'se puede abrir m s de una conexi RC = send(Sock, ByVal MsgBuffer, Len(DatatoSend), 0) 'If an error occurs send an error message and 'reset the winsock If RC = SOCKET_ERROR Then Process.Caption = "No se puede enviar." & CRLF & _ Str$(WSAGetLastError()) & _ GetWSAErrorString(WSAGetLastError()) closesocket Sock RC = WSACleanup() Screen.MousePointer = vbDefault Exit Sub End If End Sub Private Sub Text2_KeyPress(KeyAscii As Integer) If KeyAscii = vbKeyReturn Then btnFecha.SetFocus End If End Sub Private Sub tmr_Timer() If iPic = 124 Then iPic = 101 Set curSelect = LoadResPicture(iPic, vbResBitmap) Picture1(0).Picture = curSelect iPic = iPic + 1 End Sub